Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue65/pools/IBDatabasePool.pas

Pascal/Delphi Source File | 2000-11-28 | 14.6 KB | 582 lines

unit IBDatabasePool;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  IBDatabase, IBQuery, DB;

{$R IBDatabasePool.dcr}

type
  EDatabasePoolMax = class(EDatabaseError);
  TIBDatabasePool = class(TComponent)
  private
    ConList : TThreadList;
    InUseList : TBits;
    FMaxConnections: integer;
    FDatabaseName: String;
    FParams: TStrings;
    FAutoOpen: boolean;
    procedure SetMaxConnections(const Value: integer);
    procedure SetParams(const Value: TStrings);
  protected
  public
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
    procedure OpenAll; virtual;                      // Openall not necessary if AutoOpen = True
    procedure CloseAll; virtual;                     // If you are trying to reopen all connections, you do not need to call CloseAll before calling OpenAll
    function AcquireDB : TIBDatabase; virtual;
    procedure ReleaseDB(IBDB : TIBDatabase); virtual;  // Make sure to call Release for every Aquire!
  published
    property MaxConnections : integer read FMaxConnections write SetMaxConnections;
    property DatabaseName : String read FDatabaseName write FDatabaseName;  // If changing Databasename after connections are made, you must reopen all connections;
    property Params : TStrings read FParams write SetParams;                // ie.. 'USER_NAME=Sysdba'#13'PASSWORD=masterkey'
    Property AutoOpen : boolean read FAutoOpen write FAutoOpen;
  end;

  TIBQueryQueue = class;
  EQueryQueueMax = class(EDatabaseError);

  TIBQueueItem = class(TObject)
  private
    FExecuteQuery: boolean;
    FReadOnly: boolean;
    FText: string;
    FQueryObject: TIBQuery;
    FIsReady: boolean;
    FNeedFree: boolean;
  public
    constructor Create; virtual;
    property Text : string read FText write FText;
    property ReadOnly : boolean read FReadOnly write FReadOnly;
    property ExecuteQuery : boolean read FExecuteQuery write FExecuteQuery;
    property QueryObject : TIBQuery read FQueryObject write FQueryObject;
    property IsReady : boolean read FIsReady write FIsReady;
    property NeedFree : boolean read FNeedFree write FNeedFree;
  end;

  TIBQueueManager = class(TThread)
  private
    IBQueryQueue : TIBQueryQueue;
  protected
    procedure Execute; override;
  public
    constructor Create(QQ : TIBQueryQueue);
  end;

  TIBQueryQueue = class(TComponent)
  private
    FIBDatabasePool: TIBDatabasePool;
    Queue : TThreadList;
    QueueManagerList : TTHreadList;
    FMaxQueueFactor: integer;
    FQueueManagers: integer;
    procedure SetIBDatabasePool(const Value: TIBDatabasePool);
    procedure SetQueueManagers(const Value: integer);
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    constructor Create(AOwner : TComponent); override;
    destructor Destroy; override;
    procedure ExecuteSQL(Text : string; Wait : boolean = False); virtual;    // Use for Insert, Update or Delete statements
    function OpenSQL(Text : string; ReadOnly : boolean) : TIBQuery; virtual; // Use for Select statements
    procedure CloseSQL(Query : TIBQuery); virtual;                           // Must call when done with opened query.
  published
    property IBDatabasePool : TIBDatabasePool read FIBDatabasePool write SetIBDatabasePool;
    property MaxQueueFactor : integer read FMaxQueueFactor write FMaxQueueFactor;  // This number multiplied by the number of DB connections in a pool will be the max queued SQL statements
    property QueueManagers : integer read FQueueManagers write SetQueueManagers;   // Set this to the number of Queue managers you wish to have running simultaneously.  Setting this too high could limit performance.
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Interbase', [TIBDatabasePool]);
  RegisterComponents('Interbase', [TIBQueryQueue]);
end;

{ TIBDatabasePool }

function TIBDatabasePool.AcquireDB: TIBDatabase;
var
  i : integer;
begin
  Result := nil;
  with ConList.LockList do
  try
    i := InUseList.OpenBit;
    if i >= Count then raise EDatabasePoolMax.Create('All database connections are in use. Cannot continue with Aquire.');
    Result := Items[i];
    InUseList[i] := True;
  finally
    ConList.UnlockList;
  end;
end;

procedure TIBDatabasePool.CloseAll;
var
  i : integer;
begin
  with ConList.LockList do
  try
    for i := 0 to Count-1 do
    begin
      if TIBDatabase(Items[i]).Connected then
        TIBDatabase(Items[i]).Close;
    end;
  finally
    ConList.UnlockList;
  end;
end;

constructor TIBDatabasePool.Create(AOwner: TComponent);
begin
  inherited;
  ConList := TThreadList.Create;
  InUseList := TBits.Create;
  FParams := TStringList.Create;
  FMaxConnections := 0;
  FDatabaseName := '';
end;

destructor TIBDatabasePool.Destroy;
begin
  ConList.Free;
  InUseList.Free;
  FParams.Free;
  inherited;
end;


procedure TIBDatabasePool.OpenAll;
var
  i : integer;
begin
  with ConList.LockList do
  try
    for i := 0 to Count-1 do
    begin
      if TIBDatabase(Items[i]).Connected then
        TIBDatabase(Items[i]).Close;
      TIBDatabase(Items[i]).DatabaseName := FDatabaseName;
      TIBDatabase(Items[i]).Params.Clear;
      TIBDatabase(Items[i]).Params.AddStrings(FParams);
      TIBDatabase(Items[i]).Open;
    end;
  finally
    ConList.UnlockList;
  end;
end;

procedure TIBDatabasePool.ReleaseDB(IBDB: TIBDatabase);
begin
  with ConList.LockList do
  try
    InUseList[IndexOf(IBDB)] := False;
  finally
    ConList.UnlockList;
  end;
end;

procedure TIBDatabasePool.SetMaxConnections(const Value: integer);
var
  i : integer;
  IBDB : TIBDatabase;
begin
  if Value <=0 then raise EQueryQueueMax.Create('There must be a positive number of Max Connectiosn');
  if csDesigning in ComponentState then
  begin
    FMaxConnections := Value;
    exit;
  end;
  if FMaxConnections < Value then
  begin
    for i := FMaxConnections to Value do
    begin
      IBDB := TIBDatabase.Create(nil);
      IBDB.Params.AddStrings(FParams);
      IBDB.DatabaseName := DatabaseName;
      IBDB.LoginPrompt := False;
      if FAutoOpen then IBDB.Open;
      ConList.Add(IBDB);
    end;
  end else
  begin
    if FMaxConnections > Value then
    begin
      with ConList.LockList do
      try
        while Count < Value do
        begin
          TIBDatabase(Items[Count-1]).Close;
          TIBDatabase(Items[Count-1]).Free;
          Delete(Count-1);
        end;
      finally
        ConList.UnlockList;
      end;
    end;
  end;

  FMaxConnections := Value;
  InUseList.Size := Value+1;
end;

procedure TIBDatabasePool.SetParams(const Value: TStrings);
begin
  FParams.Assign(Value);
end;

{ TIBQueryQueue }

procedure TIBQueryQueue.CloseSQL(Query: TIBQuery);
var
  IBDB : TIBDatabase;
begin
  IBDB := nil;
  try
    try
      try
        Query.Transaction.Commit;
        Query.Close;
        IBDB := Query.Database;
      except
        Query.Transaction.Rollback;
        raise;
      end;
    finally
      Query.Free;
    end;
  finally;
    IBDatabasePool.ReleaseDB(IBDB);
  end;
end;

constructor TIBQueryQueue.Create(AOwner: TComponent);
begin
  inherited;
  Queue := TThreadList.Create;
  QueueManagerList := TThreadList.Create;
  FMaxQueueFactor := 3;
  FQueueManagers := 1;
end;

destructor TIBQueryQueue.Destroy;
var
  i : integer;
begin
  with QueueManagerList.LockList do
  try
    for i := 0 to count-1 do
    begin
      TIBQueueManager(Items[i]).Terminate;
      TIBQueueManager(Items[i]).Free;
    end;
  finally
    QueueManagerList.UnLockList;
  end;
  QueueManagerList.Free;
  with Queue.LockList do
  try
    for i := 0 to count-1 do
      TIBQueueItem(Items[i]).Free;
  finally
    Queue.UnlockList;
  end;
  Queue.Free;
  inherited;
end;

procedure TIBQueryQueue.ExecuteSQL(Text: string; Wait : boolean = False);
var
  IBDB : TIBDatabase;
  Query : TIBQuery;
  Trans : TIBTransaction;
  o : TIBQueueItem;
begin
  try
    IBDB := IBDatabasePool.AcquireDB;
  except
    with Queue.LockList do
    try
      if Count >= IBDatabasePool.MaxConnections*FMaxQueueFactor then
        raise Exception.Create('The database queue is full.  Please try again in a few seconds.');
    finally
      Queue.UnlockList;
    end;
    o := TIBQueueItem.Create;
    o.Text := Text;
    o.ReadOnly := False;
    o.ExecuteQuery := True;
    Queue.Add(o);
    try
      if Wait then
        while not o.IsReady do
          Application.ProcessMessages
      else
        o.NeedFree := True;
    finally
      o.Free;
    end;
    exit;
  end;
  try
    Query := TIBQuery.Create(nil);
    Trans := TIBTransaction.Create(Query);
    try
      Query.Database := IBDB;
      Query.Transaction := Trans;
      Trans.AddDatabase(IBDB);
      IBDB.AddTransaction(Trans);

      Trans.Params.Add('WRITE');

      Query.SQL.Text := Text;

      Trans.StartTransaction;
      try
        Query.ExecSQL;
        Trans.Commit;
      except
        Trans.Rollback;
        raise;
      end;
    finally
      Query.Free;
    end;
  finally
    IBDatabasePool.ReleaseDB(IBDB);
  end;
end;

procedure TIBQueryQueue.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited;
  if (Operation = opRemove) then
  begin
    if (AComponent = FIBDatabasePool) then
      FIBDatabasePool := nil;
  end;
end;


function TIBQueryQueue.OpenSQL(Text: string; ReadOnly: boolean): TIBQuery;
var
  IBDB : TIBDatabase;
  Query : TIBQuery;
  Trans : TIBTransaction;
  o : TIBQueueItem;
begin
  Query := TIBQuery.Create(nil);
  Trans := TIBTransaction.Create(Query);
  try
    try
      IBDB := IBDatabasePool.AcquireDB;
    except
      with Queue.LockList do
      try
        if Count >= IBDatabasePool.MaxConnections*FMaxQueueFactor then
          raise Exception.Create('The database queue is full.  Please try again in a few seconds.');
      finally
        Queue.UnlockList;
      end;
      o := TIBQueueItem.Create;
      o.Text := Text;
      o.ReadOnly := ReadOnly;
      o.ExecuteQuery := False;
      o.QueryObject := Query;
      Queue.Add(o);
      try
        while not o.IsReady do
          Application.ProcessMessages;
      finally
        o.Free;
      end;
      Result := Query;
      exit;
    end;
    try
      Query.Database := IBDB;
      Query.Transaction := Trans;
      Trans.AddDatabase(IBDB);
      IBDB.AddTransaction(Trans);

      if ReadOnly then
        Trans.Params.Add('READ')
      else
        Trans.Params.Add('WRITE');

      Query.SQL.Text := Text;
      Trans.StartTransaction;
      Query.Open;
      Result := Query;
    except
      IBDatabasePool.ReleaseDB(IBDB);
      raise;
    end;
  except
    Query.Free;
    raise;
  end;
end;

procedure TIBQueryQueue.SetIBDatabasePool(const Value: TIBDatabasePool);
begin
  FIBDatabasePool := Value;
  if assigned(FIBDatabasePool) then
  begin
    FIBDatabasePool.FreeNotification(self);
  end;
end;

procedure TIBQueryQueue.SetQueueManagers(const Value: integer);
var
  i : integer;
begin
  if Value <=0 then raise Exception.Create('There must be a positive number of Queue Managers');
  if csDesigning in ComponentState then
  begin
    FQueueManagers := Value;
    exit;
  end;
  if (FQueueManagers < Value) or (csLoading in ComponentState) then
  begin
    for i := FQueueManagers to Value do
    begin
      QueueManagerList.Add(TIBQueueManager.Create(Self));
    end;
  end else
  begin
    if FQueueManagers > Value then
    begin
      with QueueManagerList.LockList do
      try
        while Count < Value do
        begin
          TIBQueueManager(Items[Count-1]).Terminate;
          Delete(Count-1);
        end;
      finally
        QueueManagerList.UnlockList;
      end;
    end;
  end;
end;

{ TIBQueueManager }

constructor TIBQueueManager.Create(QQ: TIBQueryQueue);
begin
  inherited Create(True);
  IBQueryQueue := QQ;
  Priority := tpNormal;
  Resume;
end;

procedure TIBQueueManager.Execute;
var
  iCount : integer;
  IBDB : TIBDatabase;
  Query : TIBQuery;
  Trans : TIBTransaction;
  o : TIBQueueItem;
  OkToRelease : boolean;
begin
  OkToRelease := True;
  IBDB := nil;
  o := nil;
  while not Terminated do
  begin
    Priority := tpNormal;
    if not assigned(IBQueryQueue.IBDatabasePool) then continue;
    with IBQueryQueue.Queue.LockList do
    try
      iCount := Count;
    finally
      IBQueryQueue.Queue.UnlockList;
    end;
    if iCount > 0 then
    begin
      try
        IBDB := IBQueryQueue.IBDatabasePool.AcquireDB;
      except
        continue;
      end;
      Priority := tpHighest;
      try
        with IBQueryQueue.Queue.LockList do
        try
          if Count = 0 then continue;
          o := TIBQueueItem(Items[0]);
          Delete(0);
        finally
          IBQueryQueue.Queue.UnlockList;
        end;
        if not assigned(o) then raise Exception.Create('Error getting queued object');
        try
          if Assigned(o.QueryObject) then
            Query := o.QueryObject
          else
            Query := TIBQuery.Create(nil);
          Trans := TIBTransaction.Create(Query);
          try
            Query.Database := IBDB;
            Query.Transaction := Trans;
            Trans.AddDatabase(IBDB);
            IBDB.AddTransaction(Trans);

            if o.ReadOnly then
              Trans.Params.Add('READ')
            else
              Trans.Params.Add('WRITE');

            Query.SQL.Text := o.Text;
            if o.ExecuteQuery then
            begin
              Trans.StartTransaction;
              try
                Query.ExecSQL;
                Trans.Commit;
              except
                Trans.Rollback;
                raise;
              end;
            end else
            begin
              OkToRelease := False;
              Trans.StartTransaction;
              Query.Open;
            end;
            Priority := tpNormal;
          finally
            if not Assigned(o.QueryObject) then
              Query.Free;
          end;
        finally
          o.IsReady := True;
          if o.NeedFree then
            FreeAndNil(o);
        end;
      finally
        if OkToRelease then
          IBQueryQueue.IBDatabasePool.ReleaseDB(IBDB);
      end;
    end;
  end;
end;

{ TIBQueueItem }

constructor TIBQueueItem.Create;
begin
  inherited Create;
  FIsReady := False;
  FNeedFree := False;
end;

end.